home *** CD-ROM | disk | FTP | other *** search
/ Mac Mania 2 / MacMania 2.toast / Demo's / Tools&Utilities / Programming / PowerLisp 1.1 / Library / loop.lisp < prev    next >
Encoding:
Text File  |  1994-01-04  |  54.1 KB  |  1,498 lines  |  [TEXT/ROSA]
  1. ;;;      LOOP    -*- Mode:LISP; Syntax:Common-Lisp; Package:(LOOP (COMMON-LISP); Base:10; Lowercase:T -*-
  2. ;;;      **********************************************************************
  3. ;;;      ****** Common Lisp ******** LOOP Iteration Macro *********************
  4. ;;;      **********************************************************************
  5. ;;;      **** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
  6. ;;;      ******** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *************
  7. ;;;      **********************************************************************
  8.  
  9. ;;;; LOOP Iteration Macro
  10.  
  11. ;;; This is the "officially sanctioned" version of LOOP for running in
  12. ;;; Common Lisp.  It is a conversion of LOOP 829, which is fairly close to
  13. ;;; that released with Symbolics Release 6.1 (803).     This conversion was
  14. ;;; made by Glenn Burke (one of the original author/maintainers);  the
  15. ;;; work was performed at Palladian Software, in Cambridge MA, April 1986.
  16. ;;; 
  17. ;;; The current version of this file will be maintained at MIT, available
  18. ;;; for anonymous FTP on MC.LCS.MIT.EDU from the file "LSB1;CLLOOP >".    This
  19. ;;; location will no doubt change sometime in the future.
  20. ;;; 
  21. ;;; This file, like the LOOP it is derived from, has unrestricted
  22. ;;; distribution -- anyone may take it and use it.    But for the sake of
  23. ;;; consistency, bug reporting, compatibility, and users' sanity, PLEASE
  24. ;;; PLEASE PLEASE don't go overboard with fixes or changes.     Remember that
  25. ;;; this version is supposed to be compatible with the Maclisp/Zetalisp/NIL
  26. ;;; LOOP;  it is NOT intended to be "different" or "better" or "redesigned".
  27. ;;; Report bugs and propose fixes to BUG-LOOP@MC.LCS.MIT.EDU;
  28. ;;; announcements about LOOP will be made to the mailing list
  29. ;;; INFO-LOOP@MC.LCS.MIT.EDU.  Mail concerning those lists (such as requests
  30. ;;; to be added) should be sent to the BUG-LOOP-REQUEST and
  31. ;;; INFO-LOOP-REQUEST lists respectively.  Note the Change History page
  32. ;;; below...
  33. ;;; 
  34. ;;; LOOP documentation is still probably available from the MIT Laboratory
  35. ;;; for Computer Science publications office:
  36. ;;;        LCS Publications
  37. ;;;        545 Technology Square
  38. ;;;        Cambridge, MA 02139
  39. ;;; It is Technical Memo 169, "LOOP Iteration Macro", and is very old.    The
  40. ;;; most up-to-date documentation on this version of LOOP is that in the NIL
  41. ;;; Reference Manual (TR-311 from LCS Publications);  while you wouldn't
  42. ;;; want to get that (it costs nearly $15) just for LOOP documentation,
  43. ;;; those with access to a NIL manual might photocopy the chapter on LOOP.
  44. ;;; That revised documentation can be reissued as a revised technical memo
  45. ;;; if there is sufficient demand.
  46. ;;; 
  47.  
  48. ;;;; Change History
  49. ;;; jbs@think.com    10-Oct-86 I removed the &environment code so this would work for KCL
  50. ;;; [gsb@palladian] 30-apr-86 00:26     File Created from NIL's LOOP version 829
  51. ;;;------------------------------------------------------------------------
  52. ;;;------- End of official change history -- note local fixes below -------
  53. ;;;------------------------------------------------------------------------
  54. ;;;
  55. ;;; 
  56. ;;; bill@cambridge.apple.com 06/14/91  loop-for-arithmetic no longer assumes fixnum
  57. ;;; -------------- 2.0b2
  58. ;;; bill@cambridge.apple.com 03/04/91  string-length -> length
  59. ;;;--------------- 2.0b1
  60. ;;; bill@cambridge.apple.com 12/10/90  Add CL: prefix to the initial defpackage & in-package forms
  61. ;;; bill@cambridge.apple.com 09/28/90  define-loop-macro call goes after def of loop-translate
  62. ;;;                                       to eliminate compiler warnings.
  63. ;;; bill@cambridge.apple.com 09/07/90  PROVIDE goes at the end of the file!
  64. ;;;
  65. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66.  
  67. ;;;; Package setup
  68.  
  69.  
  70. ;;;The following symbols are documented as being available via SI:.     Far be
  71. ;;;it for us to define a package by that name, however we can do the
  72. ;;;following.  We will create a "loop-si-kludge" package (sounds like a
  73. ;;;fairly safe name), import the SI: symbols from there into LOOP, export
  74. ;;;them, define that people (use-package 'loop), and if they want to
  75. ;;;maintain source compatibility they can add the SI nickname the
  76. ;;;loop-si-kludge package.    How's that?
  77.  
  78. ;(in-package 'loop-si-kludge)
  79.  
  80. ;(export '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring?
  81. ;          loop-named-variable loop-simplep loop-simplep-1
  82. ;          loop-sequencer loop-sequence-elements-path))
  83.  
  84. ;(cl:defpackage loop (:use common-lisp))
  85. ;(cl:in-package :loop)
  86. (eval-when (:load-toplevel :compile-toplevel :execute)
  87.  
  88. (provide :loop)
  89. (in-package :loop)        ; no defpackage yet  RGC
  90. )
  91.  
  92. ;(use-package '(loop-si-kludge))
  93.  
  94. ;shadow?
  95.  
  96. ;(shadow '(loop loop-finish define-loop-macro define-loop-path
  97. ;               define-loop-sequence-path))
  98. ; 
  99. ;(shadow '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring?
  100. ;          loop-named-variable loop-simplep loop-simplep-1
  101. ;          loop-sequencer loop-sequence-elements-path))
  102.  
  103. ;(shadow '(loop:lisp)) wrong! AHR howard
  104. (shadow '(loop) 'common-lisp)  ; No shadow functions yet -- RGC
  105.  
  106.  
  107. (export '(loop loop-finish define-loop-macro define-loop-path
  108.                define-loop-sequence-path))
  109.  
  110. (export '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring?
  111.           loop-named-variable loop-simplep loop-simplep-1
  112.           loop-sequencer loop-sequence-elements-path))
  113.  
  114. ;require?
  115.  
  116.  
  117. ;;;; Macro Environment Setup
  118.  
  119. ; Hack up the stuff for data-types.     DATA-TYPE? will always be a macro
  120. ; so that it will not require the data-type package at run time if
  121. ; all uses of the other routines are conditionalized upon that value.
  122. (eval-when (eval compile)
  123.   ; Crock for DATA-TYPE? derives from DTDCL.  We just copy it rather
  124.   ; than load it in, which requires knowing where it comes from (sigh).
  125.   ; 
  126.   (defmacro data-type? (frob)
  127.     (let ((foo (gensym)))
  128.       `((lambda (,foo)
  129.           ;; NIL croaks if nil given to GET...    No it doesn't any more!     But:
  130.           ;; Every Lisp should (but doesn't) croak if randomness given to GET
  131.           ;; LISPM croaks (of course) if randomness given to get-pname
  132.           (and (symbolp ,foo)
  133.                (or (get ,foo ':data-type)
  134.                    (and (setq ,foo (find-symbol (symbol-name ,foo) (find-package 'keyword)))
  135.                         (get ,foo ':data-type)))))
  136.         ,frob)))
  137. )
  138.  
  139. ;;; The uses of this macro are retained in the CL version of loop, in case they are
  140. ;;; needed in a particular implementation.    Originally dating from the use of the
  141. ;;; Zetalisp COPYLIST* function, this is used in situations where, were cdr-coding
  142. ;;; in use, having cdr-NIL at the end of the list might be suboptimal because the
  143. ;;; end of the list will probably be RPLACDed and so cdr-normal should be used instead.
  144. (defmacro loop-copylist* (l)
  145.   `(copy-list ,l))
  146.  
  147.  
  148. ;;;; Random Macros
  149.  
  150. (defmacro loop-simple-error (unquoted-message &optional (datum nil datump))
  151.   `(error ,(if datump "LOOP:  ~S ~A" "LOOP:  ~A")
  152.           ',unquoted-message ,@(and datump (list datum))))
  153.  
  154.  
  155. (defmacro loop-warn (unquoted-message &optional (datum nil datump))
  156.   (if datump
  157.       `(warn ,(concatenate 'string "LOOP: " unquoted-message " -- ~{~S~^ ~}")
  158.              ,datum)
  159.       `(warn ',(concatenate 'string "LOOP: " unquoted-message))))
  160.  
  161.  
  162. ;; (defmacro loop-pop-source () '(pop loop-source-code))    ;; RGC
  163.  
  164. (defun loop-pop-source ()
  165.   (if loop-source-code
  166.       (pop loop-source-code)
  167.       (error "LOOP source code ran out when another token was expected.")))
  168.  
  169.  
  170. (defmacro loop-gentemp (&optional (pref ''loopvar-))
  171.   `(gentemp (symbol-name ,pref)))
  172.  
  173.  
  174. ;;;; Setq Hackery
  175.  
  176. ; Note:     LOOP-MAKE-PSETQ is NOT flushable depending on the existence
  177. ; of PSETQ, unless PSETQ handles destructuring.     Even then it is
  178. ; preferable for the code LOOP produces to not contain intermediate
  179. ; macros, especially in the PDP10 version.
  180.  
  181. (defun loop-make-psetq (frobs)
  182.     (and frobs
  183.          (loop-make-setq
  184.             (list (car frobs)
  185.                   (if (null (cddr frobs)) (cadr frobs)
  186.                       `(prog1 ,(cadr frobs)
  187.                               ,(loop-make-psetq (cddr frobs))))))))
  188.  
  189.  
  190. (defvar loop-use-system-destructuring?
  191.     nil)
  192.  
  193. (defvar loop-desetq-temporary)
  194.  
  195. ; Do we want this???  It is, admittedly, useful...
  196. ;(defmacro loop-desetq (&rest x)
  197. ;  (let ((loop-desetq-temporary nil))
  198. ;      (let ((setq-form (loop-make-desetq x)))
  199. ;        (if loop-desetq-temporary
  200. ;            `((lambda (,loop-desetq-temporary) ,setq-form) nil)
  201. ;            setq-form))))
  202.  
  203.  
  204. (defun loop-make-desetq (x)
  205.    (if loop-use-system-destructuring?
  206.        (cons (do ((l x (cddr l))) ((null l) 'setq)
  207.                (or (and (not (null (car l))) (symbolp (car l)))
  208.                    (return 'desetq)))
  209.              x)
  210.        (do ((x x (cddr x)) (r nil) (var) (val))
  211.            ((null x) (and r (cons 'setq r)))
  212.          (setq var (car x) val (cadr x))
  213.          (cond ((and (not (atom var))
  214.                      (not (atom val))
  215.                      (not (and (member (car val) '(car cdr cadr cddr caar cdar))
  216.                                (atom (cadr val)))))
  217.                   (setq x (list* (or loop-desetq-temporary
  218.                                      (setq loop-desetq-temporary
  219.                                            (loop-gentemp 'loop-desetq-)))
  220.                                  val var loop-desetq-temporary (cddr x)))))
  221.          (setq r (nconc r (loop-desetq-internal (car x) (cadr x)))))))
  222.  
  223.  
  224. (defun loop-desetq-internal (var val)
  225.   (cond ((null var) nil)
  226.         ((atom var) (list var val))
  227.         (t (nconc (loop-desetq-internal (car var) `(car ,val))
  228.                   (loop-desetq-internal (cdr var) `(cdr ,val))))))
  229.  
  230.  
  231. (defun loop-make-setq (pairs)
  232.     (and pairs (loop-make-desetq pairs)))
  233.  
  234.  
  235. (defparameter loop-keyword-alist                        ;clause introducers
  236.      '( (named loop-do-named)
  237.         (initially loop-do-initially)
  238.         (finally loop-do-finally)
  239.         (nodeclare loop-nodeclare)
  240.         (do loop-do-do)
  241.         (doing loop-do-do)
  242.         (return loop-do-return)
  243.         (collect loop-do-collect list)
  244.         (collecting loop-do-collect list)
  245.         (append loop-do-collect append)
  246.         (appending loop-do-collect append)
  247.         (nconc loop-do-collect nconc)
  248.         (nconcing loop-do-collect nconc)
  249.         (count loop-do-collect count)
  250.         (counting loop-do-collect count)
  251.         (sum loop-do-collect sum)
  252.         (summing loop-do-collect sum)
  253.         (maximize loop-do-collect max)
  254.         (minimize loop-do-collect min)
  255.         (always loop-do-always nil) ;Normal, do always
  256.         (never loop-do-always t)    ; Negate the test on always.
  257.         (thereis loop-do-thereis)
  258.         (while loop-do-while nil while)        ; Normal, do while
  259.         (until loop-do-while t until)        ; Negate the test on while
  260.         (when loop-do-when nil when)        ; Normal, do when
  261.         (if loop-do-when nil if)    ; synonymous
  262.         (unless loop-do-when t unless)        ; Negate the test on when
  263.         (with loop-do-with)))
  264.  
  265.  
  266. (defparameter loop-iteration-keyword-alist
  267.     `((for loop-do-for)
  268.       (as loop-do-for)
  269.       (repeat loop-do-repeat)))
  270.  
  271.  
  272. (defparameter loop-for-keyword-alist                    ;Types of FOR
  273.      '( (= loop-for-equals)
  274.         (first loop-for-first)
  275.         (in loop-list-stepper car)
  276.         (on loop-list-stepper nil)
  277.         (from loop-for-arithmetic from)
  278.         (downfrom loop-for-arithmetic downfrom)
  279.         (upfrom loop-for-arithmetic upfrom)
  280.         (below loop-for-arithmetic below)
  281.         (to loop-for-arithmetic to)
  282.         (being loop-for-being)))
  283.  
  284. (defvar loop-prog-names)
  285.  
  286.  
  287. (defvar loop-macro-environment) ;Second arg to macro functions,
  288.                                         ;passed to macroexpand.
  289.  
  290. (defvar loop-path-keyword-alist nil)            ; PATH functions
  291. (defvar loop-named-variables)                    ; see LOOP-NAMED-VARIABLE
  292. (defvar loop-variables)                    ;Variables local to the loop
  293. (defvar loop-declarations)                        ; Local dcls for above
  294. (defvar loop-nodeclare)                    ; but don't declare these
  295. (defvar loop-variable-stack)
  296. (defvar loop-declaration-stack)
  297. (defvar loop-desetq-crocks)                        ; see loop-make-variable
  298. (defvar loop-desetq-stack)                        ; and loop-translate-1
  299. (defvar loop-prologue)                            ;List of forms in reverse order
  300. (defvar loop-wrappers)                            ;List of wrapping forms, innermost first
  301. (defvar loop-before-loop)
  302. (defvar loop-body)                                ;..
  303. (defvar loop-after-body)                        ;.. for FOR steppers
  304. (defvar loop-epilogue)                            ;..
  305. (defvar loop-after-epilogue)                    ;So COLLECT's RETURN comes after FINALLY
  306. (defvar loop-conditionals)                        ;If non-NIL, condition for next form in body
  307.   ;The above is actually a list of entries of the form
  308.   ;(cond (condition forms...))
  309.   ;When it is output, each successive condition will get
  310.   ;nested inside the previous one, but it is not built up
  311.   ;that way because you wouldn't be able to tell a WHEN-generated
  312.   ;COND from a user-generated COND.
  313.   ;When ELSE is used, each cond can get a second clause
  314.  
  315. (defvar loop-when-it-variable)                    ;See LOOP-DO-WHEN
  316. (defvar loop-never-stepped-variable)            ; see LOOP-FOR-FIRST
  317. (defvar loop-emitted-body?)                        ; see LOOP-EMIT-BODY,
  318.                                                 ; and LOOP-DO-FOR
  319. (defvar loop-iteration-variables)                ; LOOP-MAKE-ITERATION-VARIABLE
  320. (defvar loop-iteration-variablep)                ; ditto
  321. (defvar loop-collect-cruft)                        ; for multiple COLLECTs (etc)
  322. (defvar loop-source-code)
  323. (defvar loop-duplicate-code nil)  ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC
  324.  
  325.  
  326. ;;;; Construct a value return
  327.  
  328.  
  329. (defun loop-construct-return (form)
  330.   (if loop-prog-names
  331.       `(return-from ,(car loop-prog-names) ,form)
  332.       `(return ,form)))
  333.  
  334. ;;;; Token Hackery
  335.  
  336. ;Compare two "tokens".    The first is the frob out of LOOP-SOURCE-CODE,
  337. ;the second a symbol to check against.
  338.  
  339. (defun loop-tequal (x1 x2)
  340.   (and (symbolp x1) (string= x1 x2)))
  341.  
  342.  
  343. (defun loop-tassoc (kwd alist)
  344.   (and (symbolp kwd) (assoc kwd alist :test #'string=)))
  345.  
  346.  
  347. (defun loop-tmember (kwd list)
  348.   (and (symbolp kwd) (member kwd list :test #'string=)))
  349.  
  350. (defmacro define-loop-macro (keyword)
  351.   "Makes KEYWORD, which is a LOOP keyword, into a Lisp macro that may
  352. introduce a LOOP form.    This facility exists mostly for diehard users of
  353. a predecessor of LOOP.    Unconstrained use is not advised, as it tends to
  354. decrease the transportability of the code and needlessly uses up a
  355. function name."
  356.   (or (eq keyword 'loop)
  357.       (loop-tassoc keyword loop-keyword-alist)
  358.       (loop-tassoc keyword loop-iteration-keyword-alist)
  359.       (loop-simple-error "not a loop keyword - define-loop-macro" keyword))
  360. ;  #-kcl    ; this doesn't work -- RGC
  361. ;  `(progn
  362. ;     (defmacro ,keyword (&whole whole-form &rest keywords-and-args &environment env)
  363. ;       (declare (ignore keywords-and-args))
  364. ;       (loop-translate whole-form env))
  365. ;;    #+symbolics  ;; tab correctly
  366. ;;     (pushnew '(loop . zwei:indent-loop) zwei:*lisp-indent-offset-alist* :test #'equal)
  367. ;     )
  368. ;  #+kcl    ; this doesn't work -- RGC
  369.   `(setf (macro-function ',keyword)
  370.          #'(lambda (whole-form &optional env)    ;; RGC  (added &optional)
  371.              (loop-translate whole-form env))))
  372.  
  373.  
  374. (defmacro loop-finish () 
  375.   "Causes the iteration to terminate \"normally\", the same as implicit
  376. termination by an iteration driving clause, or by use of WHILE or
  377. UNTIL -- the epilogue code (if any) will be run, and any implicitly
  378. collected result will be returned as the value of the LOOP."
  379.   '(go end-loop))
  380.  
  381. (defun loop-translate (x loop-macro-environment)
  382.   (loop-translate-1 x))
  383.  
  384. ;;(let ((ccl::*warn-if-redefine-kernel* nil)
  385. ;;      (ccl::*warn-if-redefine* nil))
  386. (define-loop-macro loop)
  387.  
  388.  
  389. (defun loop-end-testify (list-of-forms)
  390.     (if (null list-of-forms) nil
  391.         `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
  392.                     (car list-of-forms)
  393.                     (cons 'or list-of-forms))
  394.            (go end-loop))))
  395.  
  396. (defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b
  397.                                                lastdiff)
  398.     (do ((l1 (nreverse loop-before-loop) (cdr l1))
  399.          (l2 (nreverse loop-after-body) (cdr l2)))
  400.         ((equal l1 l2)
  401.            (setq loop-body (nconc (delete nil l1) (nreverse loop-body))))
  402.       (push (car l1) before) (push (car l2) after))
  403.     (cond ((not (null loop-duplicate-code))
  404.              (setq loop-before-loop (nreverse (delete nil before))
  405.                    loop-after-body (nreverse (delete nil after))))
  406.           (t (setq loop-before-loop nil loop-after-body nil
  407.                    before (nreverse before) after (nreverse after))
  408.              (do ((bb before (cdr bb)) (aa after (cdr aa)))
  409.                  ((null aa))
  410.                (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa))
  411.                      ((not (loop-simplep (car aa)))        ;Mustn't duplicate
  412.                       (return nil))))
  413.              (cond (lastdiff  ;Down through lastdiff should be duplicated
  414.                     (do nil (nil)
  415.                       (and (car before) (push (car before) loop-before-loop))
  416.                       (and (car after) (push (car after) loop-after-body))
  417.                       (setq before (cdr before) after (cdr after))
  418.                       (and (eq after (cdr lastdiff)) (return nil)))
  419.                     (setq loop-before-loop (nreverse loop-before-loop)
  420.                           loop-after-body (nreverse loop-after-body))))
  421.              (do ((bb (nreverse before) (cdr bb))
  422.                   (aa (nreverse after) (cdr aa)))
  423.                  ((null aa))
  424.                (setq a (car aa) b (car bb))
  425.                (cond ((and (null a) (null b)))
  426.                      ((equal a b)
  427.                         (loop-output-group groupb groupa)
  428.                         (push a loop-body)
  429.                         (setq groupb nil groupa nil))
  430.                      (t (and a (push a groupa)) (and b (push b groupb)))))
  431.              (loop-output-group groupb groupa)))
  432.     (and loop-never-stepped-variable
  433.          (push `(setq ,loop-never-stepped-variable nil) loop-after-body))
  434.     nil)
  435.  
  436.  
  437. (defun loop-output-group (before after)
  438.     (and (or after before)
  439.          (let ((v (or loop-never-stepped-variable
  440.                       (setq loop-never-stepped-variable
  441.                             (loop-make-variable
  442.                               (loop-gentemp 'loop-iter-flag-) t nil)))))
  443.             (push (cond ((not before)
  444.                           `(unless ,v (progn ,@after)))
  445.                         ((not after)
  446.                           `(when ,v (progn ,@before)))
  447.                         (t `(cond (,v ,@before) (t ,@after))))
  448.                   loop-body))))
  449.  
  450.  
  451. (defun loop-translate-1 (loop-source-code-form)
  452.   (let ((loop-source-code loop-source-code-form))
  453.   (and (eq (car loop-source-code) 'loop)
  454.        (setq loop-source-code (cdr loop-source-code)))
  455.   (do ((loop-iteration-variables nil)
  456.        (loop-iteration-variablep nil)
  457.        (loop-variables nil)
  458.        (loop-nodeclare nil)
  459.        (loop-named-variables nil)
  460.        (loop-declarations nil)
  461.        (loop-desetq-crocks nil)
  462.        (loop-variable-stack nil)
  463.        (loop-declaration-stack nil)
  464.        (loop-desetq-stack nil)
  465.        (loop-prologue nil)
  466.        (loop-wrappers nil)
  467.        (loop-before-loop nil)
  468.        (loop-body nil)
  469.        (loop-emitted-body? nil)
  470.        (loop-after-body nil)
  471.        (loop-epilogue nil)
  472.        (loop-after-epilogue nil)
  473.        (loop-conditionals nil)
  474.        (loop-when-it-variable nil)
  475.        (loop-never-stepped-variable nil)
  476.        (loop-desetq-temporary nil)
  477.        (loop-prog-names nil)
  478.        (loop-collect-cruft nil)
  479.        (keyword)
  480.        (tem)
  481.        (progvars))
  482.       ((null loop-source-code)
  483.        (and loop-conditionals
  484.             (loop-simple-error "Hanging conditional in loop macro"
  485.                                (caadar loop-conditionals)))
  486.        (loop-optimize-duplicated-code-etc)
  487.        (loop-bind-block)
  488.        (and loop-desetq-temporary (push loop-desetq-temporary progvars))
  489.        (setq tem `(block ,(car loop-prog-names)
  490.                     (let ,progvars
  491.                       (tagbody
  492.                         ,@(nreverse loop-prologue)
  493.                         ,@loop-before-loop
  494.                      next-loop
  495.                         ,@loop-body
  496.                         ,@loop-after-body
  497.                         (go next-loop)
  498.                         (go end-loop)
  499.                      end-loop
  500.                         ,@(nreverse loop-epilogue)
  501.                         ,@(nreverse loop-after-epilogue)))))
  502.        (do ((vars) (dcls) (crocks))
  503.            ((null loop-variable-stack))
  504.          (setq vars (car loop-variable-stack)
  505.                loop-variable-stack (cdr loop-variable-stack)
  506.                dcls (car loop-declaration-stack)
  507.                loop-declaration-stack (cdr loop-declaration-stack)
  508.                tem (list tem))
  509.          (and (setq crocks (pop loop-desetq-stack))
  510.               (push (loop-make-desetq crocks) tem))
  511.          (and dcls (push (cons 'declare dcls) tem))
  512.          (cond ((do ((l vars (cdr l))) ((null l) nil)
  513.                   (and (not (atom (car l)))
  514.                        (or (null (caar l)) (not (symbolp (caar l))))
  515.                        (return t)))
  516.                   (setq tem `(let ,(nreverse vars) ,@tem)))
  517.                (t (let ((lambda-vars nil) (lambda-vals nil))
  518.                     (do ((l vars (cdr l)) (v)) ((null l))
  519.                       (cond ((atom (setq v (car l)))
  520.                                (push v lambda-vars)
  521.                                (push nil lambda-vals))
  522.                             (t (push (car v) lambda-vars)
  523.                                (push (cadr v) lambda-vals))))
  524.                     (setq tem `((lambda ,lambda-vars ,@tem)
  525.                                 ,@lambda-vals))))))
  526.        (do ((l loop-wrappers (cdr l))) ((null l))
  527.          (setq tem (append (car l) (list tem))))
  528.        tem)
  529.     ;;The following commented-out code is what comes from the newest source
  530.     ;; code in use in NIL.    The code in use following it comes from about version
  531.     ;; 803, that in use in symbolics release 6.1, for instance.     To turn on the
  532.     ;; implicit DO feature, switch them and fix loop-get-form to just pop the source.
  533.     (if (symbolp (setq keyword (car loop-source-code)))
  534.         (loop-pop-source)
  535.       (setq keyword 'do))
  536.     (if (setq tem (loop-tassoc keyword loop-keyword-alist))
  537.         (apply (cadr tem) (cddr tem))
  538.         (if (setq tem (loop-tassoc
  539.                          keyword loop-iteration-keyword-alist))
  540.             (loop-hack-iteration tem)
  541.             (if (loop-tmember keyword '(and else))
  542.                 ; Alternative is to ignore it, ie let it go around to the
  543.                 ; next keyword...
  544.                 (loop-simple-error
  545.                    "secondary clause misplaced at top level in LOOP macro"
  546.                    (list keyword (car loop-source-code)
  547.                          (cadr loop-source-code)))
  548.                 (loop-simple-error
  549.                    "unknown keyword in LOOP macro" keyword))))
  550. )))
  551.  
  552.  
  553. (defun loop-bind-block ()
  554.    (cond ((not (null loop-variables))
  555.             (push loop-variables loop-variable-stack)
  556.             (push loop-declarations loop-declaration-stack)
  557.             (setq loop-variables nil loop-declarations nil)
  558.             (push loop-desetq-crocks loop-desetq-stack)
  559.             (setq loop-desetq-crocks nil))))
  560.  
  561.  
  562. ;Get FORM argument to a keyword.  Read up to atom.    PROGNify if necessary.
  563. (defun loop-get-progn-1 ()
  564.   (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms))
  565.        (nextform (car loop-source-code) (car loop-source-code)))
  566.       ((atom nextform) (nreverse forms))))
  567.  
  568. (defun loop-get-progn ()
  569.   (let ((forms (loop-get-progn-1)))
  570.     (if (null (cdr forms)) (car forms) (cons 'progn forms))))
  571.  
  572. (defun loop-get-form (for)
  573.   ;; Until implicit DO is installed, use the following.     Then, replace it with
  574.   ;; just loop-pop-source.
  575.   (let ((forms (loop-get-progn-1)))
  576.     (cond ((null (cdr forms)) (car forms))
  577.           (t (loop-warn 
  578. "The use of multiple forms with an implicit PROGN in this context
  579. is considered obsolete, but is still supported for the time being.
  580. If you did not intend to use multiple forms here, you probably omitted a DO.
  581. If the use of multiple forms was intentional, put a PROGN in your code.
  582. The offending clause"
  583.                 (if (atom for) (cons for forms) (append for forms)))
  584.              (cons 'progn forms)))))
  585.  
  586.  
  587. ;;;This function takes a substitutable expression containing generic arithmetic
  588. ;;; of some form or another, and a data type name, and substitutes for the function
  589. ;;; any type-specific functions for that type in the implementation.
  590. (defun loop-typed-arith (substitutable-expression data-type)
  591.   (declare (ignore data-type))
  592.   substitutable-expression)
  593.  
  594. (defvar loop-floating-point-types
  595.         '(flonum float short-float single-float double-float long-float))
  596.  
  597. (defun loop-typed-init (data-type)
  598.   (let ((tem nil))
  599.     (cond ((data-type? data-type) (initial-value data-type))
  600.           ((loop-tmember data-type '(fixnum integer number)) 0)
  601.           ((setq tem (car (loop-tmember
  602.                             data-type loop-floating-point-types)))
  603.            (cond ((member tem '(flonum float)) 0.0)
  604.                  (t (coerce 0 tem)))))))
  605.  
  606.  
  607. (defun loop-make-variable (name initialization dtype)
  608.   (cond ((null name)
  609.            (cond ((not (null initialization))
  610.                     (push (list (setq name (loop-gentemp 'loop-ignore-))
  611.                                 initialization)
  612.                           loop-variables)
  613.                       (push `(ignore ,name) loop-declarations))))
  614.         ((atom name)
  615.            (cond (loop-iteration-variablep
  616.                     (if (member name loop-iteration-variables)
  617.                         (loop-simple-error
  618.                            "Duplicated iteration variable somewhere in LOOP"
  619.                            name)
  620.                         (push name loop-iteration-variables)))
  621.                  ((assoc name loop-variables)
  622.                     (loop-simple-error
  623.                        "Duplicated var in LOOP bind block" name)))
  624.            (or (symbolp name)
  625.                (loop-simple-error "Bad variable somewhere in LOOP" name))
  626.            (loop-declare-variable name dtype)
  627.            ; We use ASSOC on this list to check for duplications (above),
  628.            ; so don't optimize out this list:
  629.            (push (list name (or initialization (loop-typed-init dtype)))
  630.                  loop-variables))
  631.         (initialization
  632.            (cond (loop-use-system-destructuring?
  633.                     (loop-declare-variable name dtype)
  634.                     (push (list name initialization) loop-variables))
  635.                  (t (let ((newvar (loop-gentemp 'loop-destructure-)))
  636.                       (push (list newvar initialization) loop-variables)
  637.                       ; LOOP-DESETQ-CROCKS gathered in reverse order.
  638.                       (setq loop-desetq-crocks
  639.                             (list* name newvar loop-desetq-crocks))
  640.                       (loop-make-variable name nil dtype)))))
  641.         (t (let ((tcar nil) (tcdr nil))
  642.              (if (atom dtype) (setq tcar (setq tcdr dtype))
  643.                (setq tcar (car dtype) tcdr (cdr dtype)))
  644.              (loop-make-variable (car name) nil tcar)
  645.              (loop-make-variable (cdr name) nil tcdr))))
  646.   name)
  647.  
  648.  
  649. (defun loop-make-iteration-variable (name initialization dtype)
  650.     (let ((loop-iteration-variablep t))
  651.        (loop-make-variable name initialization dtype)))
  652.  
  653.  
  654. (defun loop-declare-variable (name dtype)
  655.     (cond ((or (null name) (null dtype)) nil)
  656.           ((symbolp name)
  657.              (cond ((member name loop-nodeclare))
  658.                    ((data-type? dtype)
  659.                       (setq loop-declarations
  660.                             (append (variable-declarations dtype name)
  661.                                     loop-declarations)))
  662.                    (t (push `(type ,dtype ,name) loop-declarations))))
  663.           ((consp name)
  664.               (cond ((consp dtype)
  665.                        (loop-declare-variable (car name) (car dtype))
  666.                        (loop-declare-variable (cdr name) (cdr dtype)))
  667.                     (t (loop-declare-variable (car name) dtype)
  668.                        (loop-declare-variable (cdr name) dtype))))
  669.           (t (loop-simple-error "can't hack this"
  670.                                 (list 'loop-declare-variable name dtype)))))
  671.  
  672.  
  673. (defun loop-constantp (form)
  674.   (constantp form))
  675.  
  676. (defun loop-maybe-bind-form (form data-type?)
  677.     ; Consider implementations which will not keep EQ quoted constants
  678.     ; EQ after compilation & loading.
  679.     ; Note FUNCTION is not hacked, multiple occurences might cause the
  680.     ; compiler to break the function off multiple times!
  681.     ; Hacking it probably isn't too important here anyway.    The ones that
  682.     ; matter are the ones that use it as a stepper (or whatever), which
  683.     ; handle it specially.
  684.     (if (loop-constantp form) form
  685.         (loop-make-variable (loop-gentemp 'loop-bind-) form data-type?)))
  686.  
  687.  
  688. (defun loop-optional-type ()
  689.     (let ((token (car loop-source-code)))
  690.         (and (not (null token))
  691.              (or (not (atom token))
  692.                  (data-type? token)
  693.                  (loop-tmember token '(fixnum integer number notype))
  694.                  (loop-tmember token loop-floating-point-types))
  695.              (loop-pop-source))))
  696.  
  697.  
  698. ;Incorporates conditional if necessary
  699. (defun loop-make-conditionalization (form)
  700.   (cond ((not (null loop-conditionals))
  701.            (rplacd (last (car (last (car (last loop-conditionals)))))
  702.                    (list form))
  703.            (cond ((loop-tequal (car loop-source-code) 'and)
  704.                     (loop-pop-source)
  705.                     nil)
  706.                  ((loop-tequal (car loop-source-code) 'else)
  707.                     (loop-pop-source)
  708.                     ;; If we are already inside an else clause, close it off
  709.                     ;; and nest it inside the containing when clause
  710.                     (let ((innermost (car (last loop-conditionals))))
  711.                       (cond ((null (cddr innermost)))    ;Now in a WHEN clause, OK
  712.                             ((null (cdr loop-conditionals))
  713.                              (loop-simple-error "More ELSEs than WHENs"
  714.                                                 (list 'else (car loop-source-code)
  715.                                                       (cadr loop-source-code))))
  716.                             (t (setq loop-conditionals (cdr (nreverse loop-conditionals)))
  717.                                (rplacd (last (car (last (car loop-conditionals))))
  718.                                        (list innermost))
  719.                                (setq loop-conditionals (nreverse loop-conditionals)))))
  720.                     ;; Start a new else clause
  721.                     (rplacd (last (car (last loop-conditionals)))
  722.                             (list (list 't)))
  723.                     nil)
  724.                  (t ;Nest up the conditionals and output them
  725.                      (do ((prev (car loop-conditionals) (car l))
  726.                           (l (cdr loop-conditionals) (cdr l)))
  727.                          ((null l))
  728.                        (rplacd (last (car (last prev))) (list (car l))))
  729.                      (prog1 (car loop-conditionals)
  730.                             (setq loop-conditionals nil)))))
  731.         (t form)))
  732.  
  733. (defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form)))
  734.    (cond ((not (null z))
  735.             (cond (loop-emitted-body? (push z loop-body))
  736.                   (t (push z loop-before-loop) (push z loop-after-body))))))
  737.  
  738. (defun loop-emit-body (form)
  739.   (setq loop-emitted-body? t)
  740.   (loop-pseudo-body form))
  741.  
  742.  
  743. (defun loop-do-named ()
  744.   (let ((name (loop-pop-source)))
  745.     (unless (and name (symbolp name))
  746.       (loop-simple-error "Bad name for your loop construct" name))
  747.     ;If this don't come first, LOOP will be confused about how to return
  748.     ; from the prog when it tries to generate such code
  749.     (when (or loop-before-loop loop-body loop-after-epilogue)
  750.       (loop-simple-error "NAMED clause occurs too late" name))
  751.     (when (cdr (setq loop-prog-names (cons name loop-prog-names)))
  752.       (loop-simple-error "Too many names for your loop construct"
  753.                          loop-prog-names))))
  754.  
  755. (defun loop-do-initially ()
  756.   (push (loop-get-progn) loop-prologue))
  757.  
  758. (defun loop-nodeclare (&aux (varlist (loop-pop-source)))
  759.     (or (null varlist)
  760.         (consp varlist)
  761.         (loop-simple-error "Bad varlist to nodeclare loop clause" varlist))
  762.     (setq loop-nodeclare (append varlist loop-nodeclare)))
  763.  
  764. (defun loop-do-finally ()
  765.   (push (loop-get-progn) loop-epilogue))
  766.  
  767. (defun loop-do-do ()
  768.   (loop-emit-body (loop-get-progn)))
  769.  
  770. (defun loop-do-return ()
  771.    (loop-pseudo-body (loop-construct-return (loop-get-form 'return))))
  772.  
  773.  
  774.  
  775.  
  776. (defun loop-do-collect (type)
  777.   (let ((var nil) (form nil) (tem nil) (tail nil) (dtype nil) (cruft nil) (rvar nil)
  778.         (ctype (case type
  779.                  ((max min) 'maxmin)
  780.                  ((nconc list append) 'list)
  781.                  ((count sum) 'sum)
  782. ;                 ((member type '(max min)) 'maxmin)
  783.                  (t (error "LOOP internal error:  ~S is an unknown collecting keyword."
  784.                            type)))))
  785.     (setq form (loop-get-form type) dtype (loop-optional-type))
  786.     (cond ((loop-tequal (car loop-source-code) 'into)
  787.              (loop-pop-source)
  788.              (setq rvar (setq var (loop-pop-source)))))
  789.     ; CRUFT will be (varname ctype dtype var tail (optional tem))
  790.     (cond ((setq cruft (assoc var loop-collect-cruft))
  791.              (cond ((not (eq ctype (car (setq cruft (cdr cruft)))))
  792.                       (loop-simple-error
  793.                          "incompatible LOOP collection types"
  794.                          (list ctype (car cruft))))
  795.                    ((and dtype (not (eq dtype (cadr cruft))))
  796.                       ;Conditional should be on data-type reality
  797.                     (error "~A and ~A Unequal data types into ~A"
  798.                            dtype (cadr cruft) (car cruft))))
  799.              (setq dtype (car (setq cruft (cdr cruft)))
  800.                    var (car (setq cruft (cdr cruft)))
  801.                    tail (car (setq cruft (cdr cruft)))
  802.                    tem (cadr cruft))
  803.              (and (eq ctype 'maxmin)
  804.                   (not (atom form)) (null tem)
  805.                   (rplaca (cdr cruft)
  806.                           (setq tem (loop-make-variable
  807.                                        (loop-gentemp 'loop-maxmin-)
  808.                                        nil dtype)))))
  809.           (t (unless dtype
  810.                (setq dtype (case type
  811.                              (count 'fixnum)
  812.                              ((min max sum) 'number))))
  813.              (unless var
  814.                (push (loop-construct-return (setq var (loop-gentemp)))
  815.                      loop-after-epilogue))
  816.              (loop-make-iteration-variable var nil dtype)
  817.              (cond ((eq ctype 'maxmin)
  818.                       ;Make a temporary.
  819.                       (unless (atom form)
  820.                         (setq tem (loop-make-variable
  821.                                     (loop-gentemp) nil dtype)))
  822.                       ;Use the tail slot of the collect database to hold a
  823.                       ; flag which says we have been around once already.
  824.                       (setq tail (loop-make-variable
  825.                                    (loop-gentemp 'loop-maxmin-fl-) t nil)))
  826.                    ((eq ctype 'list)
  827.                     ;For dumb collection, we need both a tail and a flag var
  828.                     ; to tell us whether we have iterated.
  829.                     (setq tail (loop-make-variable (loop-gentemp) nil nil)
  830.                           tem (loop-make-variable (loop-gentemp) nil nil))))
  831.              (push (list rvar ctype dtype var tail tem)
  832.                    loop-collect-cruft)))
  833.     (loop-emit-body
  834.         (case type
  835.           (count (setq tem `(setq ,var (,(loop-typed-arith '1+ dtype)
  836.                                         ,var)))
  837.                  (if (or (eq form t) (equal form ''t))
  838.                      tem
  839.                      `(when ,form ,tem)))
  840.           (sum `(setq ,var (,(loop-typed-arith '+ dtype) ,form ,var)))
  841.           ((max min)
  842.              (let ((forms nil) (arglist nil))
  843.                 ; TEM is temporary, properly typed.
  844.                 (and tem (setq forms `((setq ,tem ,form)) form tem))
  845.                 (setq arglist (list var form))
  846.                 (push (if (loop-tmember dtype '(fixnum flonum))
  847.                           ; no contagious arithmetic
  848.                           `(when (or ,tail
  849.                                      (,(loop-typed-arith
  850.                                          (if (eq type 'max) '< '>)
  851.                                          dtype)
  852.                                       ,@arglist))
  853.                              (setq ,tail nil ,@arglist))
  854.                           ; potentially contagious arithmetic -- must use
  855.                           ; MAX or MIN so that var will be contaminated
  856.                           `(setq ,var (cond (,tail (setq ,tail nil) ,form)
  857.                                             (t (,type ,@arglist)))))
  858.                       forms)
  859.                 (if (cdr forms) (cons 'progn (nreverse forms)) (car forms))))
  860.           (t (case type
  861.                 (list (setq form (list 'list form)))
  862.                 (append (or (and (not (atom form)) (eq (car form) 'list))
  863.                             (setq form `(copy-list ,form)))))
  864.              (let ((q `(if ,tail (cdr (rplacd ,tail ,tem))
  865.                          (setq ,var ,tem))))
  866.                 (if (and (not (atom form)) (eq (car form) 'list) (cdr form))
  867.                     `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q))
  868.                     `(when (setq ,tem ,form) (setq ,tail (last ,q))))))))))
  869.  
  870.  
  871. (defun loop-cdrify (arglist form)
  872.     (do ((size (length arglist) (- size 4)))
  873.         ((< size 4)
  874.          (if (zerop size) form
  875.              (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) (t 'cdddr))
  876.                    form)))
  877.       (declare (type fixnum size))
  878.       (setq form (list 'cddddr form))))
  879.  
  880.  
  881.  
  882. (defun loop-do-while (negate? kwd &aux (form (loop-get-form kwd)))
  883.   (and loop-conditionals (loop-simple-error
  884.                            "not allowed inside LOOP conditional"
  885.                            (list kwd form)))
  886.   (loop-pseudo-body `(,(if negate? 'when 'unless)
  887.                       ,form (go end-loop))))
  888.  
  889.  
  890. (defun loop-do-when (negate? kwd)
  891.   (let ((form (loop-get-form kwd)) (cond nil))
  892.     (cond ((loop-tequal (cadr loop-source-code) 'it)
  893.              ;WHEN foo RETURN IT and the like
  894.              (setq cond `(setq ,(loop-when-it-variable) ,form))
  895.              (setq loop-source-code                ;Plug in variable for IT
  896.                    (list* (car loop-source-code)
  897.                           loop-when-it-variable
  898.                           (cddr loop-source-code))))
  899.           (t (setq cond form)))
  900.     (and negate? (setq cond `(not ,cond)))
  901.     (setq loop-conditionals (nconc loop-conditionals `((cond (,cond)))))))
  902.  
  903. (defun loop-do-with ()
  904.   (do ((var) (equals) (val) (dtype)) (nil)
  905.     (setq var (loop-pop-source) equals (car loop-source-code))
  906.     (cond ((loop-tequal equals '=)
  907.              (loop-pop-source)
  908.              (setq val (loop-get-form (list 'with var '=)) dtype nil))
  909.           ((or (loop-tequal equals 'and)
  910.                (loop-tassoc equals loop-keyword-alist)
  911.                (loop-tassoc equals loop-iteration-keyword-alist))
  912.              (setq val nil dtype nil))
  913.           (t (setq dtype (loop-optional-type) equals (car loop-source-code))
  914.              (cond ((loop-tequal equals '=)
  915.                       (loop-pop-source)
  916.                       (setq val (loop-get-form (list 'with var dtype '=))))
  917.                    ((and (not (null loop-source-code))
  918.                          (not (loop-tassoc equals loop-keyword-alist))
  919.                          (not (loop-tassoc
  920.                                  equals loop-iteration-keyword-alist))
  921.                          (not (loop-tequal equals 'and)))
  922.                       (loop-simple-error "Garbage where = expected" equals))
  923.                    (t (setq val nil)))))
  924.     (loop-make-variable var val dtype)
  925.     (if (not (loop-tequal (car loop-source-code) 'and)) (return nil)
  926.         (loop-pop-source)))
  927.   (loop-bind-block))
  928.  
  929. (defun loop-do-always (negate?)
  930.   (let ((form (loop-get-form 'always)))
  931.     (loop-emit-body `(,(if negate? 'when 'unless) ,form
  932.                       ,(loop-construct-return nil)))
  933.     (push (loop-construct-return t) loop-after-epilogue)))
  934.  
  935. ;THEREIS expression
  936. ;If expression evaluates non-nil, return that value.
  937. (defun loop-do-thereis ()
  938.    (loop-emit-body `(when (setq ,(loop-when-it-variable)
  939.                                 ,(loop-get-form 'thereis))
  940.                       ,(loop-construct-return loop-when-it-variable))))
  941.  
  942.  
  943. ;;;; Hacks
  944.  
  945. (defun loop-simplep (expr)
  946.     (if (null expr) 0
  947.       (catch 'loop-simplep
  948.         (let ((ans (loop-simplep-1 expr)))
  949.           (declare (type fixnum ans))
  950.           (and (< ans 20.) ans)))))
  951.  
  952. (defvar loop-simplep
  953.         '(> < <= >= /= + - 1+ 1- ash equal atom setq prog1 prog2 and or = aref char schar sbit svref))
  954.  
  955. (defun loop-simplep-1 (x)
  956.   (let ((z 0))
  957.     (declare (type fixnum z))
  958.     (cond ((loop-constantp x) 0)
  959.           ((atom x) 1)
  960.           ((eq (car x) 'cond)
  961.              (do ((cl (cdr x) (cdr cl))) ((null cl))
  962.                (do ((f (car cl) (cdr f))) ((null f))
  963.                  (setq z (+ (loop-simplep-1 (car f)) z 1))))
  964.              z)
  965.           ((symbolp (car x))
  966.              (let ((fn (car x)) (tem nil))
  967.                (cond ((setq tem (get fn 'loop-simplep))
  968.                         (if (typep tem 'fixnum) (setq z tem)
  969.                             (setq z (funcall tem x) x nil)))
  970.                      ((member fn '(null not eq go return progn)))
  971.                      ((member fn '(car cdr)) (setq z 1))
  972.                      ((member fn '(caar cadr cdar cddr)) (setq z 2))
  973.                      ((member fn '(caaar caadr cadar caddr
  974.                                    cdaar cdadr cddar cdddr))
  975.                         (setq z 3))
  976.                      ((member fn '(caaaar caaadr caadar caaddr
  977.                                    cadaar cadadr caddar cadddr
  978.                                    cdaaar cdaadr cdadar cdaddr
  979.                                    cddaar cddadr cdddar cddddr))
  980.                         (setq z 4))
  981.                      ((member fn loop-simplep) (setq z 2))
  982.                      (t (multiple-value-bind (new-form expanded-p)
  983.                               (macroexpand-1 x loop-macro-environment)
  984.                           (if expanded-p
  985.                               (setq z (loop-simplep-1 new-form) x nil)
  986.                             (throw 'loop-simplep nil)))))
  987.                (do ((l (cdr x) (cdr l))) ((null l))
  988.                  (setq z (+ (loop-simplep-1 (car l)) 1 z)))
  989.                z))
  990.           (t (throw 'loop-simplep nil)))))
  991.  
  992.  
  993. ;;;; The iteration driver
  994. (defun loop-hack-iteration (entry)
  995.   (do ((last-entry entry)
  996.        (source loop-source-code loop-source-code)
  997.        (pre-step-tests nil)
  998.        (steps nil)
  999.        (post-step-tests nil)
  1000.        (pseudo-steps nil)
  1001.        (pre-loop-pre-step-tests nil)
  1002.        (pre-loop-steps nil)
  1003.        (pre-loop-post-step-tests nil)
  1004.        (pre-loop-pseudo-steps nil)
  1005.        (tem) (data) (foo) (bar))
  1006.       (nil)
  1007.     ; Note we collect endtests in reverse order, but steps in correct
  1008.     ; order.  LOOP-END-TESTIFY does the nreverse for us.
  1009.     (setq tem (setq data (apply (cadr entry) (cddr entry))))
  1010.     (and (car tem) (push (car tem) pre-step-tests))
  1011.     (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
  1012.     (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
  1013.     (setq pseudo-steps
  1014.           (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
  1015.     (setq tem (cdr tem))
  1016.     (and (or loop-conditionals loop-emitted-body?)
  1017.          (or tem pre-step-tests post-step-tests pseudo-steps)
  1018.          (let ((cruft (list (car entry) (car source)
  1019.                             (cadr source) (caddr source))))
  1020.             (if loop-emitted-body?
  1021.                 (loop-simple-error
  1022.                    "Iteration is not allowed to follow body code" cruft)
  1023.                 (loop-simple-error
  1024.                    "Iteration starting inside of conditional in LOOP"
  1025.                    cruft))))
  1026.     (or tem (setq tem data))
  1027.     (and (car tem) (push (car tem) pre-loop-pre-step-tests))
  1028.     (setq pre-loop-steps
  1029.           (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
  1030.     (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
  1031.     (setq pre-loop-pseudo-steps
  1032.           (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
  1033.     (cond ((or (not (loop-tequal (car loop-source-code) 'and))
  1034.                (and loop-conditionals
  1035.                     (not (loop-tassoc (cadr loop-source-code)
  1036.                                          loop-iteration-keyword-alist))))
  1037.              (setq foo (list (loop-end-testify pre-loop-pre-step-tests)
  1038.                              (loop-make-psetq pre-loop-steps)
  1039.                              (loop-end-testify pre-loop-post-step-tests)
  1040.                              (loop-make-setq pre-loop-pseudo-steps))
  1041.                    bar (list (loop-end-testify pre-step-tests)
  1042.                              (loop-make-psetq steps)
  1043.                              (loop-end-testify post-step-tests)
  1044.                              (loop-make-setq pseudo-steps)))
  1045.              (cond ((not loop-conditionals)
  1046.                       (setq loop-before-loop (nreconc foo loop-before-loop)
  1047.                             loop-after-body (nreconc bar loop-after-body)))
  1048.                    (t ((lambda (loop-conditionals)
  1049.                           (push (loop-make-conditionalization
  1050.                                    (cons 'progn (delete nil foo)))
  1051.                                 loop-before-loop))
  1052.                        (mapcar #'(lambda (x)    ;Copy parts that will get rplacd'ed
  1053.                                    (cons (car x)
  1054.                                          (mapcar #'(lambda (x) (loop-copylist* x)) (cdr x))))
  1055.                                loop-conditionals))
  1056.                       (push (loop-make-conditionalization
  1057.                                (cons 'progn (delete nil bar)))
  1058.                             loop-after-body)))
  1059.              (loop-bind-block)
  1060.              (return nil)))
  1061.     (loop-pop-source) ; flush the "AND"
  1062.     (setq entry (cond ((setq tem (loop-tassoc
  1063.                                     (car loop-source-code)
  1064.                                     loop-iteration-keyword-alist))
  1065.                          (loop-pop-source)
  1066.                          (setq last-entry tem))
  1067.                       (t last-entry)))))
  1068.  
  1069.  
  1070. ;FOR variable keyword ..args..
  1071. (defun loop-do-for ()
  1072.   (let ((var (loop-pop-source))
  1073.         (data-type? (loop-optional-type))
  1074.         (keyword (loop-pop-source))
  1075.         (first-arg nil)
  1076.         (tem nil))
  1077.     (setq first-arg (loop-get-form (list 'for var keyword)))
  1078.     (or (setq tem (loop-tassoc keyword loop-for-keyword-alist))
  1079.         (loop-simple-error
  1080.            "Unknown keyword in FOR or AS clause in LOOP"
  1081.            (list 'for var keyword)))
  1082.     (apply (cadr tem) var first-arg data-type? (cddr tem))))
  1083.  
  1084.  
  1085. (defun loop-do-repeat ()
  1086.     (let ((var (loop-make-variable
  1087.                   (loop-gentemp 'loop-repeat-)
  1088.                   (loop-get-form 'repeat) 'fixnum)))
  1089.        `((not (,(loop-typed-arith 'plusp 'fixnum) ,var))
  1090.          () ()
  1091.          (,var (,(loop-typed-arith '1- 'fixnum) ,var)))))
  1092.  
  1093.  
  1094. ; Kludge the First
  1095. (defun loop-when-it-variable ()
  1096.     (or loop-when-it-variable
  1097.         (setq loop-when-it-variable
  1098.               (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
  1099.  
  1100.  
  1101.  
  1102. (defun loop-for-equals (var val data-type?)
  1103.   (cond ((loop-tequal (car loop-source-code) 'then)
  1104.            ;FOR var = first THEN next
  1105.            (loop-pop-source)
  1106.            (loop-make-iteration-variable var val data-type?)
  1107.            `(() (,var ,(loop-get-form (list 'for var '= val 'then))) () ()
  1108.              () () () ()))
  1109.         (t (loop-make-iteration-variable var nil data-type?)
  1110.            (let ((varval (list var val)))
  1111.              (cond (loop-emitted-body?
  1112.                     (loop-emit-body (loop-make-setq varval))
  1113.                     '(() () () ()))
  1114.                    (`(() ,varval () ())))))))
  1115.  
  1116. (defun loop-for-first (var val data-type?)
  1117.     (or (loop-tequal (car loop-source-code) 'then)
  1118.         (loop-simple-error "found where THEN expected in FOR ... FIRST"
  1119.                            (car loop-source-code)))
  1120.     (loop-pop-source)
  1121.     (loop-make-iteration-variable var nil data-type?)
  1122.     `(() (,var ,(loop-get-form (list 'for var 'first val 'then))) () ()
  1123.       () (,var ,val) () ()))
  1124.  
  1125.  
  1126. (defun loop-list-stepper (var val data-type? fn)
  1127.     (let ((stepper (cond ((loop-tequal (car loop-source-code) 'by)
  1128.                             (loop-pop-source)
  1129.                             (loop-get-form (list 'for var
  1130.                                                  (if (eq fn 'car) 'in 'on)
  1131.                                                  val 'by)))
  1132.                          (t '(function cdr))))
  1133.           (var1 nil) (stepvar nil) (step nil) (et nil) (pseudo nil))
  1134.        (setq step (if (or (atom stepper)
  1135.                           (not (member (car stepper) '(quote function))))
  1136.                       `(funcall ,(setq stepvar (loop-gentemp 'loop-fn-)))
  1137.                       (list (cadr stepper))))
  1138.        (cond ((and (atom var)
  1139.                    ;; (eq (car step) 'cdr)
  1140.                    (not fn))
  1141.                 (setq var1 (loop-make-iteration-variable var val data-type?)))
  1142.              (t (loop-make-iteration-variable var nil data-type?)
  1143.                 (setq var1 (loop-make-variable
  1144.                              (loop-gentemp 'loop-list-) val nil))
  1145.                 (setq pseudo (list var (if fn (list fn var1) var1)))))
  1146.        (rplacd (last step) (list var1))
  1147.        (and stepvar (loop-make-variable stepvar stepper nil))
  1148.        (setq stepper (list var1 step) et `(null ,var1))
  1149.        (if (not pseudo) `(() ,stepper ,et () () () ,et ())
  1150.            (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper)
  1151.                `((null (setq ,@stepper)) () () ,pseudo ,et () () ,pseudo)))))
  1152.  
  1153.  
  1154. (defun loop-for-arithmetic (var val data-type? kwd)
  1155.   ; Args to loop-sequencer:
  1156.   ; indexv indexv-type variable? vtype? sequencev? sequence-type
  1157.   ; stephack? default-top? crap prep-phrases
  1158.   (loop-sequencer
  1159.      var (or data-type? #|'fixnum|#) nil nil nil nil nil nil `(for ,var ,kwd ,val)
  1160.      (cons (list kwd val)
  1161.            (loop-gather-preps
  1162.               '(from upfrom downfrom to upto downto above below by)
  1163.               nil))))
  1164.  
  1165.  
  1166. (defun loop-named-variable (name)
  1167.     (let ((tem (loop-tassoc name loop-named-variables)))
  1168.        (cond ((null tem) (loop-gentemp))
  1169.              (t (setq loop-named-variables (delete tem loop-named-variables))
  1170.                 (cdr tem)))))
  1171.  
  1172.  
  1173. ; Note:     path functions are allowed to use loop-make-variable, hack
  1174. ; the prologue, etc.
  1175. (defun loop-for-being (var val data-type?)
  1176.    ; FOR var BEING something ... - var = VAR, something = VAL.
  1177.    ; If what passes syntactically for a pathname isn't, then
  1178.    ; we trap to the DEFAULT-LOOP-PATH path;     the expression which looked like
  1179.    ; a path is given as an argument to the IN preposition.    Thus,
  1180.    ; by default, FOR var BEING EACH expr OF expr-2
  1181.    ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2.
  1182.    (let ((tem nil) (inclusive? nil) (ipps nil) (each? nil) (attachment nil))
  1183.      (if (or (loop-tequal val 'each) (loop-tequal val 'the))
  1184.          (setq each? 't val (car loop-source-code))
  1185.          (push val loop-source-code))
  1186.      (cond ((and (setq tem (loop-tassoc val loop-path-keyword-alist))
  1187.                  (or each? (not (loop-tequal (cadr loop-source-code)
  1188.                                                 'and))))
  1189.               ;; FOR var BEING {each} path {prep expr}..., but NOT
  1190.               ;; FOR var BEING var-which-looks-like-path AND {ITS} ...
  1191.               (loop-pop-source))
  1192.            (t (setq val (loop-get-form (list 'for var 'being)))
  1193.               (cond ((loop-tequal (car loop-source-code) 'and)
  1194.                        ;; FOR var BEING value AND ITS path-or-ar
  1195.                        (or (null each?)
  1196.                            (loop-simple-error
  1197.                               "Malformed BEING EACH clause in LOOP" var))
  1198.                        (setq ipps `((of ,val)) inclusive? t)
  1199.                        (loop-pop-source)
  1200.                        (or (loop-tmember (setq tem (loop-pop-source))
  1201.                                             '(its his her their each))
  1202.                            (loop-simple-error
  1203.                               "found where ITS or EACH expected in LOOP path"
  1204.                               tem))
  1205.                        (if (setq tem (loop-tassoc
  1206.                                         (car loop-source-code)
  1207.                                         loop-path-keyword-alist))
  1208.                            (loop-pop-source)
  1209.                            (push (setq attachment
  1210.                                        `(in ,(loop-get-form
  1211.                                               `(for ,var being \.\.\. in))))
  1212.                                  ipps)))
  1213.                     ((not (setq tem (loop-tassoc
  1214.                                        (car loop-source-code)
  1215.                                        loop-path-keyword-alist)))
  1216.                        ; FOR var BEING {each} a-r ...
  1217.                        (setq ipps (list (setq attachment (list 'in val)))))
  1218.                     (t ; FOR var BEING {each} pathname ...
  1219.                        ; Here, VAL should be just PATHNAME.
  1220.                        (loop-pop-source)))))
  1221.      (cond ((not (null tem)))
  1222.            ((not (setq tem (loop-tassoc 'default-loop-path
  1223.                                            loop-path-keyword-alist)))
  1224.               (loop-simple-error "Undefined LOOP iteration path"
  1225.                                  (cadr attachment))))
  1226.      (setq tem (funcall (cadr tem) (car tem) var data-type?
  1227.                         (nreconc ipps (loop-gather-preps (caddr tem) t))
  1228.                         inclusive? (caddr tem) (cdddr tem)))
  1229.      (and loop-named-variables
  1230.           (loop-simple-error "unused USING variables" loop-named-variables))
  1231.      ; For error continuability (if there is any):
  1232.      (setq loop-named-variables nil)
  1233.      ;; TEM is now (bindings prologue-forms . stuff-to-pass-back)
  1234.      (do ((l (car tem) (cdr l)) (x)) ((null l))
  1235.        (if (atom (setq x (car l)))
  1236.            (loop-make-iteration-variable x nil nil)
  1237.            (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
  1238.      (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue))
  1239.      (cddr tem)))
  1240.  
  1241.  
  1242. (defun loop-gather-preps (preps-allowed crockp)
  1243.    (do ((token (car loop-source-code) (car loop-source-code)) (preps nil))
  1244.        (nil)
  1245.      (cond ((loop-tmember token preps-allowed)
  1246.               (push (list (loop-pop-source)
  1247.                           (loop-get-form `(for \... being \... ,token)))
  1248.                     preps))
  1249.            ((loop-tequal token 'using)
  1250.               (loop-pop-source)
  1251.               (or crockp (loop-simple-error
  1252.                             "USING used in illegal context"
  1253.                             (list 'using (car loop-source-code))))
  1254.               (do ((z (car loop-source-code) (car loop-source-code)) (tem))
  1255.                   ((atom z))
  1256.                 (and (or (atom (cdr z))
  1257.                          (not (null (cddr z)))
  1258.                          (not (symbolp (car z)))
  1259.                          (and (cadr z) (not (symbolp (cadr z)))))
  1260.                      (loop-simple-error
  1261.                         "bad variable pair in path USING phrase" z))
  1262.                 (cond ((not (null (cadr z)))
  1263.                          (and (setq tem (loop-tassoc
  1264.                                            (car z) loop-named-variables))
  1265.                               (loop-simple-error
  1266.                                  "Duplicated var substitition in USING phrase"
  1267.                                  (list tem z)))
  1268.                          (push (cons (car z) (cadr z)) loop-named-variables)))
  1269.                 (loop-pop-source)))
  1270.            (t (return (nreverse preps))))))
  1271.  
  1272. (defun loop-add-path (name data)
  1273.     (setq loop-path-keyword-alist
  1274.           (cons (cons name data)
  1275.                 (delete (loop-tassoc name loop-path-keyword-alist)
  1276.                         loop-path-keyword-alist
  1277.                         :test #'eq)))
  1278.     nil)
  1279.  
  1280.  
  1281. (defmacro define-loop-path (names &rest cruft)
  1282.   "(DEFINE-LOOP-PATH NAMES PATH-FUNCTION LIST-OF-ALLOWABLE-PREPOSITIONS
  1283. DATUM-1 DATUM-2 ...)
  1284. Defines PATH-FUNCTION to be the handler for the path(s) NAMES, which may
  1285. be either a symbol or a list of symbols.  LIST-OF-ALLOWABLE-PREPOSITIONS
  1286. contains a list of prepositions allowed in NAMES. DATUM-i are optional;
  1287. they are passed on to PATH-FUNCTION as a list."
  1288.   (setq names (if (atom names) (list names) names))
  1289.   (let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft))
  1290.                        names)))
  1291.     `(eval-when (eval load compile) ,@forms)))
  1292.  
  1293.  
  1294. (defun loop-sequencer (indexv indexv-type
  1295.                           variable? vtype?
  1296.                           sequencev? sequence-type?
  1297.                           stephack? default-top?
  1298.                           crap prep-phrases)
  1299.    (let ((endform nil) (sequencep nil) (test nil)
  1300.          (step ; Gross me out!
  1301.                (1+ (or (loop-typed-init indexv-type) 0)))
  1302.          (dir nil) (inclusive-iteration? nil) (start-given? nil) (limit-given? nil))
  1303.      (and variable? (loop-make-iteration-variable variable? nil vtype?))
  1304.      (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
  1305.        (setq prep (caar l) form (cadar l))
  1306.        (cond ((loop-tmember prep '(of in))
  1307.                 (and sequencep (loop-simple-error
  1308.                                   "Sequence duplicated in LOOP path"
  1309.                                   (list variable? (car l))))
  1310.                 (setq sequencep t)
  1311.                 (loop-make-variable sequencev? form sequence-type?))
  1312.              ((loop-tmember prep '(from downfrom upfrom))
  1313.                 (and start-given?
  1314.                      (loop-simple-error
  1315.                         "Iteration start redundantly specified in LOOP sequencing"
  1316.                         (append crap l)))
  1317.                 (setq start-given? t)
  1318.                 (cond ((loop-tequal prep 'downfrom) (setq dir 'down))
  1319.                       ((loop-tequal prep 'upfrom) (setq dir 'up)))
  1320.                 (loop-make-iteration-variable indexv form indexv-type))
  1321.              ((cond ((loop-tequal prep 'upto)
  1322.                        (setq inclusive-iteration? (setq dir 'up)))
  1323.                     ((loop-tequal prep 'to)
  1324.                        (setq inclusive-iteration? t))
  1325.                     ((loop-tequal prep 'downto)
  1326.                        (setq inclusive-iteration? (setq dir 'down)))
  1327.                     ((loop-tequal prep 'above) (setq dir 'down))
  1328.                     ((loop-tequal prep 'below) (setq dir 'up)))
  1329.                 (and limit-given?
  1330.                      (loop-simple-error
  1331.                        "Endtest redundantly specified in LOOP sequencing path"
  1332.                        (append crap l)))
  1333.                 (setq limit-given? t)
  1334.                 (setq endform (loop-maybe-bind-form form indexv-type)))
  1335.              ((loop-tequal prep 'by)
  1336.                 (setq step (if (loop-constantp form) form
  1337.                                (loop-make-variable
  1338.                                  (loop-gentemp 'loop-step-by-)
  1339.                                  form 'fixnum))))
  1340.              (t ; This is a fatal internal error...
  1341.                 (loop-simple-error "Illegal prep in sequence path"
  1342.                                    (append crap l))))
  1343.        (and odir dir (not (eq dir odir))
  1344.             (loop-simple-error
  1345.                "Conflicting stepping directions in LOOP sequencing path"
  1346.                (append crap l)))
  1347.        (setq odir dir))
  1348.      (and sequencev? (not sequencep)
  1349.           (loop-simple-error "Missing OF phrase in sequence path" crap))
  1350.      ; Now fill in the defaults.
  1351.      (setq step (list indexv step))
  1352.      (cond ((member dir '(nil up))
  1353.               (or start-given?
  1354.                   (loop-make-iteration-variable indexv 0 indexv-type))
  1355.               (and (or limit-given?
  1356.                        (cond (default-top?
  1357.                                 (loop-make-variable
  1358.                                   (setq endform (loop-gentemp
  1359.                                                   'loop-seq-limit-))
  1360.                                   nil indexv-type)
  1361.                                 (push `(setq ,endform ,default-top?)
  1362.                                       loop-prologue))))
  1363.                    (setq test (if inclusive-iteration? '(> . args)
  1364.                                   '(>= . args))))
  1365.               (push '+ step))
  1366.            (t (cond ((not start-given?)
  1367.                        (or default-top?
  1368.                            (loop-simple-error
  1369.                               "Don't know where to start stepping"
  1370.                               (append crap prep-phrases)))
  1371.                        (loop-make-iteration-variable indexv 0 indexv-type)
  1372.                        (push `(setq ,indexv
  1373.                                     (,(loop-typed-arith '1- indexv-type)
  1374.                                      ,default-top?))
  1375.                              loop-prologue)))
  1376.               (cond ((and default-top? (not endform))
  1377.                        (setq endform (loop-typed-init indexv-type)
  1378.                              inclusive-iteration? t)))
  1379.               (and (not (null endform))
  1380.                    (setq test (if inclusive-iteration? '(< . args)
  1381.                                   '(<= . args))))
  1382.               (push '- step)))
  1383.      (and (and (numberp (caddr step)) (= (caddr step) 1))        ;Generic arith
  1384.           (rplacd (cdr (rplaca step (if (eq (car step) '+) '1+ '1-)))
  1385.                   nil))
  1386.      (rplaca step (loop-typed-arith (car step) indexv-type))
  1387.      (setq step (list indexv step))
  1388.      (setq test (loop-typed-arith test indexv-type))
  1389.      (setq test (subst (list indexv endform) 'args test))
  1390.      (and stephack? (setq stephack? `(,variable? ,stephack?)))
  1391.      `(() ,step ,test ,stephack?
  1392.        () () ,test ,stephack?)))
  1393.  
  1394.  
  1395. (defun loop-sequence-elements-path (path variable data-type
  1396.                                        prep-phrases inclusive?
  1397.                                        allowed-preps data)
  1398.     allowed-preps ; unused
  1399.     (let ((indexv (loop-named-variable 'index))
  1400.           (sequencev (loop-named-variable 'sequence))
  1401.           (fetchfun nil) (sizefun nil) (type nil) (default-var-type nil)
  1402.           (crap `(for ,variable being the ,path)))
  1403.        (cond ((not (null inclusive?))
  1404.                 (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path))
  1405.                 (loop-simple-error "Can't step sequence inclusively" crap)))
  1406.        (setq fetchfun (car data)
  1407.              sizefun (car (setq data (cdr data)))
  1408.              type (car (setq data (cdr data)))
  1409.              default-var-type (cadr data))
  1410.        (list* nil nil ; dummy bindings and prologue
  1411.               (loop-sequencer
  1412.                  indexv 'fixnum
  1413.                  variable (or data-type default-var-type)
  1414.                  sequencev type
  1415.                  `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev)
  1416.                  crap prep-phrases))))
  1417.  
  1418.  
  1419.  
  1420. (defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun
  1421.                                      &optional sequence-type element-type)
  1422.   "Defines a sequence iiteration path.  PATH-NAME-OR-NAMES is either an
  1423. atomic path name or a list of path names.  FETCHFUN is a function of
  1424. two arguments, the sequence and the index of the item to be fetched.
  1425. Indexing is assumed to be zero-origined.  SIZEFUN is a function of
  1426. one argument, the sequence; it should return the number of elements in
  1427. the sequence.  SEQUENCE-TYPE is the name of the data-type of the
  1428. sequence, and ELEMENT-TYPE is the name of the data-type of the elements
  1429. of the sequence."
  1430.     `(define-loop-path ,path-name-or-names
  1431.         loop-sequence-elements-path
  1432.         (of in from downfrom to downto below above by)
  1433.         ,fetchfun ,sizefun ,sequence-type ,element-type))
  1434.  
  1435.  
  1436. ;;;; Setup stuff
  1437.  
  1438.  
  1439. (mapc #'(lambda (x)
  1440.           (mapc #'(lambda (y)
  1441.                     (setq loop-path-keyword-alist
  1442.                           (cons `(,y loop-sequence-elements-path
  1443.                                   (of in from downfrom to downto
  1444.                                       below above by)
  1445.                                   ,@(cdr x))
  1446.                                 (delete (loop-tassoc
  1447.                                           y loop-path-keyword-alist)
  1448.                                         loop-path-keyword-alist
  1449.                                         :test #'eq :count 1))))
  1450.                 (car x)))
  1451.       '( ((element elements) elt length sequence)
  1452.         ;The following should be done by using ELEMENTS and type dcls...
  1453.           ((vector-element 
  1454.             vector-elements 
  1455.             array-element     ;; Backwards compatibility -- DRM
  1456.             array-elements)
  1457.            aref length vector)
  1458.           ((simple-vector-element simple-vector-elements
  1459.             simple-general-vector-element simple-general-vector-elements)
  1460.            svref simple-vector-length simple-vector)
  1461.           ((bits bit bit-vector-element bit-vector-elements)
  1462.              bit bit-vector-length bit-vector bit)
  1463.           ((simple-bit-vector-element simple-bit-vector-elements)
  1464.              sbit simple-bit-vector-length simple-bit-vector bit)
  1465.           ((character characters string-element string-elements)
  1466.            char length string string-char)
  1467.           ((simple-string-element simple-string-elements)
  1468.            schar length simple-string string-char)
  1469.         )
  1470.       )
  1471.  
  1472. ; (setf (macro-function 'lisp::loop) #'loop)
  1473. (pushnew 'loop *features*)    ;; Common-Lisp says this is correct.
  1474. (pushnew :loop *features*)    ;; But Lucid only understands this one.
  1475.  
  1476. (defun initial-value (x) x nil)
  1477. (defun variable-declarations (type &rest vars) type vars nil)
  1478.  
  1479. ; Loop exists.
  1480. (provide 'loop)
  1481.  
  1482.  
  1483.  
  1484.  
  1485.  
  1486.  
  1487.  
  1488.  
  1489.  
  1490.  
  1491.  
  1492.  
  1493.  
  1494.  
  1495.  
  1496.  
  1497.  
  1498.